home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / toplevel.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-14  |  5.9 KB  |  239 lines
  1. /* ******************************************************************** */
  2. /* toplevel.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* toplevel syntactic forms and special forms                           */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, March 1990 (Compiler rationalisation)
  10.  *     Largely just modulised variants of the originals.
  11.  *   Version 2, August 1990
  12.  *     Added 'define' (kjp)
  13.  */
  14.  
  15. #include "funcalls.h"
  16. #include "defs.h"
  17. #include "structs.h"
  18.  
  19. #include "error.h"
  20. #include "global.h"
  21.  
  22. #include "symboot.h"
  23. #include "allocate.h"
  24. #include "modules.h"
  25. #include "specials.h"
  26. #include "toplevel.h"
  27. #include "streams.h"
  28.  
  29. /* Language provided toplevel forms */
  30.  
  31. /*
  32.  * Start with the most fundamental...
  33.  *   The first argument to ALL special forms is now the module it is
  34.  *   called within - not all need it but...
  35.  */
  36.  
  37. /* Top level defining forms */
  38.  
  39. LispObject TL_define(LispObject *stacktop,LispObject mod,LispObject forms)
  40. {
  41.   LispObject bind_spec,name,type;
  42.   LispObject ret;
  43.  
  44.   if (!is_cons(forms))
  45.     CallError(stacktop,"define: no binding spec",forms,NONCONTINUABLE);
  46.  
  47.   bind_spec = CAR(forms); 
  48.  
  49.   if (is_symbol(bind_spec)) {
  50.     ret = TL_deflex(stacktop,mod,forms);
  51.     return(ret);
  52.   }
  53.  
  54.   if (!is_cons(bind_spec))
  55.     CallError(stacktop,"define: invalid binding spec",forms,NONCONTINUABLE);
  56.   
  57.   type = CAR(bind_spec); bind_spec = CDR(bind_spec);
  58.  
  59.   if (!is_cons(bind_spec))
  60.     CallError(stacktop,"define: invalid binding spec",forms,NONCONTINUABLE);
  61.  
  62.   name = CAR(bind_spec); bind_spec = CDR(bind_spec);
  63.  
  64.   if (type == sym_function) {
  65.     LispObject xx;
  66.     STACK_TMP(mod);
  67.     EUCALLSET_2(xx, Fn_cons, name, CDR(forms));
  68.     UNSTACK_TMP(mod);
  69.     ret = TL_defun(stacktop,mod,xx);
  70.     return(ret);
  71.   }
  72.  
  73.   if (type == sym_macro) {
  74.     LispObject xx;
  75.     STACK_TMP(mod);
  76.     EUCALLSET_2(xx, Fn_cons, name, CDR(forms));
  77.     UNSTACK_TMP(mod);
  78.     ret = TL_defmacro(stacktop,mod,xx);
  79.     return(ret);
  80.   }
  81.  
  82.   if (type == sym_constant) {
  83.     LispObject xx;
  84.     STACK_TMP(mod);
  85.     EUCALLSET_2(xx, Fn_cons, name, CDR(forms));
  86.     UNSTACK_TMP(mod);
  87.     ret = TL_defconstant(stacktop,mod,xx);
  88.     return(ret);
  89.   }
  90.  
  91.   CallError(stacktop,"define: unknown binding type",forms,NONCONTINUABLE);
  92.  
  93.   return(nil);
  94. }
  95.  
  96. LispObject TL_defun(LispObject *stacktop,LispObject mod,LispObject forms)
  97. {
  98.   LispObject name,fun;
  99.  
  100.   if (forms == nil)
  101.     CallError(stacktop,"defun form: no function name",nil,NONCONTINUABLE);
  102.  
  103.   name = CAR(forms); forms = CDR(forms);
  104.  
  105.   if (!is_symbol(name))
  106.     CallError(stacktop,
  107.           "defun form: non-symbolic function name",name,NONCONTINUABLE);
  108.  
  109.   /* Use name for bind and redirect to lambda!! */
  110.  
  111.   /* What we do here's questionable... */
  112.  
  113.   STACK_TMP(mod);
  114.   STACK_TMP(name);
  115.   EUCALLSET_3(fun,Sf_lambda,mod,NULL,forms);
  116.   UNSTACK_TMP(name);
  117.   UNSTACK_TMP(mod);
  118.   fun->I_FUNCTION.name = name;
  119.  
  120.   STACK_TMP(name);
  121.   (void) module_set_new_constant(stacktop,mod,name,fun);
  122.   UNSTACK_TMP(name);
  123.  
  124.   return(name);
  125. }
  126.  
  127. LispObject TL_defmacro(LispObject *stacktop,LispObject mod,LispObject forms)
  128. {
  129.   LispObject name, mac;
  130.  
  131.   if (forms == nil)
  132.     CallError(stacktop,"defmacro form: no macro name",nil,NONCONTINUABLE);
  133.  
  134.   name = CAR(forms); forms = CDR(forms);
  135.  
  136.   if (!is_symbol(name))
  137.     CallError(stacktop,
  138.           "defmacro form: non-symbolic macro name",name,NONCONTINUABLE);
  139.  
  140.   /* Use name for bind and redirect to lambda!! */
  141.  
  142.   /* What we do here's questionable... */
  143.   STACK_TMP(mod);
  144.   STACK_TMP(name);
  145.   EUCALLSET_3(mac,Sf_mlambda,mod,NULL,forms);
  146.   UNSTACK_TMP(name);
  147.   UNSTACK_TMP(mod);
  148.   STACK_TMP(name);
  149.   (void) module_set_new_constant(stacktop,mod,name,mac);
  150.   UNSTACK_TMP(name);
  151.   
  152.   return(name);
  153. }
  154.  
  155. LispObject TL_deflex(LispObject *stacktop,LispObject mod,LispObject forms)
  156. {
  157.   LispObject name,val;
  158.  
  159.   if (!is_cons(forms))
  160.     CallError(stacktop,"deflocal form: no binding name",nil,NONCONTINUABLE);
  161.  
  162.   name = CAR(forms); forms = CDR(forms);
  163.  
  164.   if (!is_symbol(name))
  165.     CallError(stacktop,"deflocal form: non-symbolic binding name",
  166.           name,NONCONTINUABLE);
  167.  
  168.   /* What we do here's questionable too... */
  169.   STACK_TMP(mod);
  170.   STACK_TMP(name);
  171.   EUCALLSET_3(val,module_eval,mod,NULL,CAR(forms));
  172.   UNSTACK_TMP(name);
  173.   UNSTACK_TMP(mod);
  174.   STACK_TMP(name);
  175.   (void) module_set_new(stacktop,mod,name,val);
  176.   UNSTACK_TMP(name);
  177.  
  178.   return(name);
  179. }
  180.  
  181. LispObject TL_defconstant(LispObject *stacktop,LispObject mod,LispObject forms)
  182. {
  183.   LispObject name,val;
  184.  
  185.   if (!is_cons(forms))
  186.     CallError(stacktop,"defconstant form: no binding name",nil,NONCONTINUABLE);
  187.  
  188.   name = CAR(forms); forms = CDR(forms);
  189.  
  190.   if (!is_symbol(name))
  191.     CallError(stacktop,"defconstant form: non-symbolic binding name",
  192.           name,NONCONTINUABLE);
  193.  
  194.   /* What we do here's questionable too... */
  195.   
  196.   STACK_TMP(mod);
  197.   STACK_TMP(name);
  198.   EUCALLSET_3(val,module_eval,mod,NULL,CAR(forms));
  199.   UNSTACK_TMP(name);
  200.   UNSTACK_TMP(mod);
  201.   STACK_TMP(name);
  202.   (void) module_set_new_constant(stacktop,mod,name,val);
  203.   UNSTACK_TMP(name);
  204.  
  205.   return(name);
  206. }
  207.  
  208. LispObject TL_defvar(LispObject *stacktop,LispObject mod,LispObject forms)
  209. {
  210.   LispObject id;
  211.  
  212.   if (!is_cons(forms))
  213.     CallError(stacktop,"defvar: illegal empty defvar form",nil,NONCONTINUABLE);
  214.  
  215.   id = CAR(forms); forms = CDR(forms);
  216.  
  217.   if (CDR(forms) != nil)
  218.     CallError(stacktop,"defvar: additional defvar forms",nil,NONCONTINUABLE);
  219.  
  220.   if (!is_symbol(id))
  221.     CallError(stacktop,"defvar: non-symbolic id",id,NONCONTINUABLE);
  222.  
  223.   if (reserved_symbol_p(id))
  224.     CallError(stacktop,"defvar: reserved id",id,NONCONTINUABLE);
  225.  
  226.   STACK_TMP(id);
  227.   EUCALLSET_3(forms,module_eval,mod,NULL,CAR(forms));
  228.   UNSTACK_TMP(id);
  229.   STACK_TMP(forms);
  230.   if ((id->SYMBOL).gvalue !=NULL) {
  231.     print_string(stacktop,StdErr(),"defvar: Illegal re-declaration of ");
  232.     STACK_TMP(id);
  233.     EUCALL_2(Fn_print,id,StdErr());
  234.     UNSTACK_TMP(id);
  235.   }
  236.   UNSTACK_TMP(forms);
  237.   return((id->SYMBOL).gvalue = forms);
  238. }
  239.